perm filename OCCULT[GEM,BGB]1 blob sn#032396 filedate 1973-03-30 generic text, type T, neo UTF8
00100	TITLE OCCULT  -  A HIDDEN LINE ELIMINATOR  -  FEBRUARY 1973.
00200	
00300	;OCCULT IS DEPENDENT ON THE WING AND EULER PRIMITIVES.
00400	
00500		EXTERN MKB,MKF,MKE,MKV
00600		EXTERN KLB,KLF,KLE,KLV
00700		EXTERN WING,LINKED
00800		EXTERN ECW,ECCW,OTHER
00900		EXTERN BGET,FCW,FCCW,VCW,VCCW
01000		EXTERN MKEV,MKFE,ESPLIT,KLEV,KLFE
01100		EXTERN INVERT
01200	
01300	;LINK NAMES RELEVANT ONLY TO OCCULT.
01400	
01500		DEFINE UFACE(Q,E)<CAR Q,7(E)>	;UBER/UNDER FACE.
01600		DEFINE UFACE.(Q,E)<DIP Q,7(E)>
01700		DEFINE TJ(Q,V)<CAR Q,7(V)>	;TJOINT LIST.
01800		DEFINE TJ.(Q,V)<DIP Q,7(V)>
01900		TJLIST:0
02000		DEFINE VALEN(Q,V)<CAR Q,7(V)>	;VERTEX VALENCE.
02100		DEFINE VALEN.(Q,V)<DIP Q,7(V)>
02200		DEFINE TJOINT(Q,V)<CAR Q,2(V)>	;TJOINT RING.
02300		DEFINE TJOIN.(Q,V)<DIP Q,2(V)>
02400	
02500	;DIAGONOSTICS.
02600	
02700		DECLARE{TIME1,TIME2}
02800		WORLD:0
02900		EXTERN EDPY,VDPY
03000		EXTERN DPYSET,DPYBUF,DPYOUT,DPYBRT,DPYBIG,BUFDPY
03100		EXTERN AIVECT,AVECT,FLODPY,DECDPY,DPYSTR,DTYO
03200		DMODE:-1
03300		ELIMIT: =12
03400		PDLTOP:0
03500		DEEPDL:BLOCK =1024
03600		WNDCNT:0	;NUMBER OF XY-SORT WINDOWS.
03700		COMCNT:0	;NUMBER OF EDGE-EDGE COMPARES.
03800	
03900	;OUTER MOST WINDOW FROM PROJECTOR.
04000	
04100		DECLARE{XPPMIN,XPPMAX,YPPMIN,YPPMAX,ZPPMIN,ZPPMAX}
04200		DECLARE{VXMIN,VXMAX,VYMIN,VYMAX,VZMIN,VZMAX}
     

00100	SUBR(OCCULT)WORLD ---------------------------------------------
00200	BEGIN OCCULT; A HIDDEN LINE ELIMINATOR.
00300	
00400		TDCA 1,1	;CLEAR DIAGONOSTIC MODE ON ENTRY.
00500		SETO 1,		;SET DIAGONOSTIC MODE ON ENTRY+1.
00600		DAC 1,DMODE
00700	
00800	;READ CLOCKS.
00900		SETZ↔TIMER↔DAC TIME1
01000		SETZ↔RUNTIM↔DAC TIME2
01100	
01200	;TRY TO HIDE VERTICES THAT WERE HIDDEN BEFORE.
01300		DZM TJLIST
01400		DZM COMCNT↔DZM WNDCNT
01500		LAC ARG1↔DAC WORLD
01600		CALL(VSCAN)
01700	
01800	;PLACE OUTERMOST WINDOW INTO THE DEEP PDL.
01900		DZM PDLTOP
02000		LACI 1,DEEPDL
02100		DZM(1)	;WINDOW CUT DIRECTION.
02200	
02300		LAC 2,ARG1
02400		DAC 2,WORLD
02500		PED 2,2		;LAST POTENT EDGE.
02600	
02700		PUSH 1,2
02800		PUSH 1,[1]	;CURRENT EDGE COUNT.
02900		PUSH 1,XPPMIN	;OUTER MOST WINDOW.
03000		PUSH 1,XPPMAX
03100		PUSH 1,YPPMIN
03200		PUSH 1,YPPMAX
03300		PUSH 1,2	;ONLY EDGE IN WINDOW.
03400		ZIP 1
03500	
03600	;DO THIS WINDOW AND ALL ITS FRIENDS.
03700		CALL(XYSORT,1)
03800		CALL(TJSCAN)
03900	 	CALL(STAT)
04000		POP1J
04100	
04200	BEND OCCULT;BGB 2/25/73 ---------------------------------------
     

00100	SUBR(XYSORT)S0-------------------------------------------------
00200	BEGIN XYSORT; DO WINDOW OR SPLIT IT IN TWO - BGB 25 FEB 1973.
00300		ACCUMULATORS{S0,S1,S2,E,A}
00400	
00500	;WINDOW DEEP STACK BLOCK FORMAT.
00600		CUTFLG	←← -7	;CUT DIRECTION SWITCH. 0 IN X. -1 IN Y.
00700		ELAST	←← -6	;LAST POTENT EDGE.
00800		EDGCNT  ←← -5	;EDGE COUNT
00900		XLO	←← -4	;XL
01000	 	XHI	←← -3	;XH
01100		YLO  	←← -2	;YL
01200		YHI 	←← -1	;YH
01300	
01400	;PUSH LATE BORN EDGES  INTO THE CURRENT WINDOW.
01500		LAC S0,ARG1		;WINDOW POINTER.
01600		LAC 1,EDGCNT(S0)	;EDGE COUNT.
01700		DIP 1,1			;XWD ECNT,,ECNT
01800		ADDI 1,-1(S0)		;XWD ECNT,,S0+ECNT-1
01900		LAC E,ELAST(S0)		;LAST POTENT EDGE.
02000	L1:	LAC A,E↔POTEN E,E
02100		JUMPE E,L2
02200		TEST E,POTENT↔GO L1
02300		PUSH 1,E
02400		GO L1
02500	L2:	HLRZM 1,EDGCNT(S0)	;UPDATE EDGE COUNT.
02600		DAC A,ELAST(S0)		;UPDATE LAST POTENT EDGE.
02700		ANDI 1,377777↔SUBI 1,DEEPDL
02800		CAMLE 1,PDLTOP↔DAC 1,PDLTOP
02900		GO .+6
03000		CALL(WINDPY,ARG1)
03100		CALL({VERIFY+2},[ASCII/XSORT/],[0])
03200	
03300	;WINDOW ZERO POINTERS AND SIZE.
03400		LAC S0,ARG1↔DAC S0,BEG0
03500		LAC EDGCNT(S0)↔DAC SIZ0
03600		LACN↔SLAC↔LAP S0↔DAC P0
03700		LAC BEG0↔ADD SIZ0↔SOS↔DAC END0
03800	
03900	;TEST FOR SMALL ENUF WINDOW POPULATION.
04000		LAC SIZ0↔CAMGE ELIMIT	;THRESHOLD EDGE COUNT.
04100		GO[CALL(ESCAN,BEG0)↔POP1J]
     

00100	;COPY POTENT RIGHT HALVES TO LEFT.
00200		LAC S0,P0
00300	L3:	LAC E,(S0)
00400		TEST E,POTENT↔SETZ E,
00500		DIP E,E↔DAC E,(S0)
00600		AOBJN S0,L3
00700	
00800	;CLIP EDGES INTO FIRST WINDOW.
00900		XL←←13 ↔ XH←←14 ↔ YL←←15 ↔ YH←←16
01000	L4:	LAC S0,BEG0↔SLACI XLO(S0)↔LAPI XL↔BLT YH ;GET WINDOW 0.
01100		LAC XH↔FSB XL↔CAMGE[1.0]↔POP1J
01200		LAC YH↔FSB YL↔CAMGE[1.0]↔POP1J
01300		LACM 1,CUTFLG(S0)↔ASH 1,1
01400		LAC XL(1)↔FAD XH(1)
01500		FSC -1↔DAC MID#
01600		SKIPE CUTFLG(S0)
01700		SKIPA YH,MID
01800		LAC XH,MID			;MAKE WINDOW 1.
01900		LAC[XWD XL,W1]↔BLT W1+3		;SAVE WINDOW 1.
02000		LAC 1,P0↔SETZ			;CLEAR INSIDER COUNT.
02100		CAR 2,(1)↔CALL(CLIP)
02200		ZIP(1)↔AOBJN 1,.-3
02300		DAC SIZ1
02400	
02500	;CLIP EDGES INTO SECOND WINDOW.
02600	L5:	LAC S0,BEG0
02700		SLACI XLO(S0)
02800		LAPI XL↔BLT YH			;GET WINDOW 0.
02900		SKIPE CUTFLG(S0)
03000		SKIPA YL,MID
03100		LAC XL,MID			;MAKE WINDOW 2.
03200		LAC 1,P0↔SETZ			;INSIDER EDGE COUNT.
03300		CDR 2,(1)↔CALL(CLIP)		;LOOP EDGES,
03400		ZAP(1)↔AOBJN 1,.-3		;THRU CLIP.
03500	
     

00100	;TEST FOR EMPTY WINDOWS.
00200	L5A:	DAC SIZ2↔ADD SIZ1
00300		SKIPN↔POP1J		;BOTH WINDOWS EMPTY.
00400		SKIPE SIZ1↔GO L5B	;WINDOW 1 EMPTY.
00500		LAC S0,BEG0↔LAC MID↔SKIPE CUTFLG(S0)↔ADDI S0,2
00600		DAC XLO(S0)↔LAC 1,P0↔HRLS(1)↔AOBJN 1,.-1
00700		SETCMM CUTFLG(S0)↔GO L4
00800	L5B:
00900		SKIPE SIZ2↔GO L6	;WINDOW 2 EMPTY.
01000		LAC S0,BEG0↔LAC MID↔SKIPE CUTFLG(S0)↔ADDI S0,2
01100		DAC XHI(S0)↔LAC 1,P0↔HLRS(1)↔AOBJN 1,.-1
01200		SETCMM CUTFLG(S0)↔GO L4
01300	
01400	;SETUP WINDOW POINTERS.
01500	L6:	LAC BEG0↔DAC BEG2
01600		ADD SIZ2↔SOS↔DAC END2
01700		ADDI 8↔DAC BEG1
01800		ADD SIZ1↔SOS↔DAC END1
01900		LACN SIZ2↔HRL BEG2↔MOVSM P2	;AOBJN POINTER 2.
02000		LACN SIZ1↔HRL BEG1↔MOVSM P1	;AOBJN POINTER 1.
02100	
02200		JSR REPACK
02300		LAC S1,BEG1
02400		LAC S2,BEG2
02500	
02600	;SETUP WINDOW HEADER DATA.
02700	L7:	LAC ELAST(S2)↔DAC ELAST(S1)		;LAST POTENT EDGE.
02800		SLACI XL↔LAPI XLO(S2)↔BLT YHI(S2)	;WINDOWS.
02900		SLACI W1↔LAPI XLO(S1)↔BLT YHI(S1)
03000		LAC SIZ1↔DAC EDGCNT(S1)		      ;WINDOW EDGE COUNTS.
03100		LAC SIZ2↔DAC EDGCNT(S2)
03200		SETCMB CUTFLG(S2)↔DAC CUTFLG(S1)   ;CUT DIRECTION SWITCH.
03300	
03400	;TWO CALLS ON XYSORT.
03500		DAC S2,ARG1	;CONVERT CURRENT EXECUTION TO SECOND.
03600		CALL(XYSORT,S1)	;FIRST CALL.
03700		GO XYSORT	;SECOND CALL.
03800	
03900	;DATA GLOBAL TO CLIP AND REPACK.
04000		DECLARE{BEG0,END0,SIZ0,P0}
04100		DECLARE{BEG1,END1,SIZ1,P1}
04200		DECLARE{BEG2,END2,SIZ2,P2}
04300		W1:0↔0↔0↔0			;WINDOW 1 SAVE AREA.
04400	
04500	;2/25/73----------------------------------------------------------
     

00100	SUBR(CLIP)-----------------------------------------------------
00200	BEGIN CLIP; CLIP DETECTOR - SKIP WHEN EDGE CROSSES WINDOW.
00300	;ARGUMENTS EXPECTED TO BE IN ACCUMULATORS XL,XH,YL,YH & 2.
00400		ACCUMULATORS{C0,C1,C2,X0,X1,X2,Y0,Y1,Y2,XL,XH,YL,YH}
00500		SKIPN 2↔POP0J
00600		PVT C1,2↔LAC X1,XPP(C1)↔LAC Y1,YPP(C1)
00700		NVT C2,2↔LAC X2,XPP(C2)↔LAC Y2,YPP(C2)
00800	
00900		SETZB C1,C2
01000		CAML Y1,YH↔IORI C1,8	;NORTH.
01100		CAMG Y1,YL↔IORI C1,4	;SOUTH.
01200		CAML X1,XH↔IORI C1,2	;EAST.
01300		CAMG X1,XL↔IORI C1,1	;WEST.
01400		JUMPE C1,HIT
01500	
01600		CAML Y2,YH↔IORI C2,8	;NORTH.
01700		CAMG Y2,YL↔IORI C2,4	;SOUTH.
01800		CAML X2,XH↔IORI C2,2	;EAST.
01900		CAMG X2,XL↔IORI C2,1	;WEST.
02000		JUMPE C2,HIT
02100	
02200		TDNE C1,C2	;WHEN V1 & V2 ARE BEYOND THE WINDOW
02300		POP0J		;IN THE SAME DIRECTION - EASY OUTSIDE.
02400	
02500	L:	LAC X0,X1↔FSB X0,X2↔MOVMS↔CAMGE X0,[1.0]↔GO[
02600		LAC Y0,Y1↔FSB Y0,Y2↔MOVMS↔CAMGE Y0,[1.0]↔GO HIT↔GO .+1]
02700		LAC X0,X1↔FAD X0,X2↔FSC X0,-1	;MIDPOINT.
02800		LAC Y0,Y1↔FAD Y0,Y2↔FSC Y0,-1
02900	
03000		SETZ C0,
03100		CAML Y0,YH↔IORI C0,8	;NORTH.
03200		CAMG Y0,YL↔IORI C0,4	;SOUTH.
03300		CAML X0,XH↔IORI C0,2	;EAST.
03400		CAMG X0,XL↔IORI C0,1	;WEST.
03500		JUMPE C0,HIT
03600	
03700		TDNE C0,C1
03800		GO .+5		;FIRST HALF EASY OUT.
03900		LAC C2,C0	;FIRST HALF STILL IN DOUBT.
04000		LAC X2,X0
04100		LAC Y2,Y0↔GO L
04200	
04300		TDNE C0,C2
04400		POP0J		;BOTH HALVES EASY OUTSIDE.
04500		LAC C1,C0	;SECOND HALF STILL IN DOUBT.
04600		LAC X1,X0
04700		LAC Y1,Y0↔GO L
04800	
04900	HIT: AOS↔AOS(P)↔POP0J
05000	
05100	BEND;2/25/73------------------------------------------------------
     

00100	REPACK:0;--------------------------------------------------------
00200	BEGIN REPACK
00300		ACCUMULATORS{LO,HI}
00400	
00500	;PACK RIGHT HALFWORDS DOWNWARDS FORMING WINDOW 2.
00600		LAC LO,BEG0↔LAC HI,END0
00700	L1:	CAML LO,HI↔GO L2
00800		CDR(LO)↔SKIPE↔AOJA LO,L1	;SCAN FOR HOLE.
00900		CDR(HI)↔SKIPN↔SOJA HI,.-2	;SCAN FOR EDGE.
01000		DAP(LO)↔SOS HI↔AOJA LO,L1	;PUT EDGE IN HOLE.
01100	
01200	;PACK LEFT HALFWORDS DOWNWARDS FORMING WINDOW 1.
01300	L2:	LAC LO,BEG0↔LAC HI,END0
01400	L3:	CAML LO,HI↔GO L4
01500		CAR(LO)↔SKIPE↔AOJA LO,L3	;SCAN FOR HOLE.
01600		CAR(HI)↔SKIPN↔SOJA HI,.-2	;SCAN FOR EDGE.
01700		DIP(LO)↔SOS HI↔AOJA LO,L3	;PUT EDGE IN HOLE.
01800	
01900	;CLEAR LEFT HALVES OF THE WINDOWS.
02000	L4:	LAC HI,END1↔LAC 1,SIZ1 		;COPY WINDOW 1 UP.
02100		LAC LO,BEG0↔ADDI LO,-1(1)
02200	L5:	CAR(LO)↔DAPZ(HI)
02300		SOS LO↔SOS HI↔SOJG 1,L5
02400		LAC 1,P2↔ZIP(1)↔AOBJN 1,.-1
02500		GO@REPACK
02600	
02700	BEND;2/25/73-----------------------------------------------------
02800	
02900	BEND XYSORT
     

00100	SUBR(VSCAN)----------------------------------------------------
00200	BEGIN VSCAN
00300		ACCUMULATORS{B,F,V,X,Y,Z}
00400		SLACI(400000)↔DAC XPPMAX↔DAC YPPMAX↔DAC ZPPMAX
00500		SETCM↔DAC XPPMIN↔DAC YPPMIN↔DAC ZPPMIN
00600		DZM EOWPTR	;WINDOW DOESN'T EXIST YET.
00700		LAC B,WORLD	;FOR ALL THE BODIES OF THE WORLD.
00800	L1:	CCW B,B
00900		TEST B,BBIT↔POP0J
01000		LAC V,B		;FOR ALL THE VERTICES OF EACH BODY.
01100	L2:	PVT V,V
01200		TEST V,VBIT↔GO L1
01300		TEST V,POTENT↔GO L2
01400	
01500	;COLLECT EXTREMA.
01600		LAC X,XPP(V)↔CAMGE X,XPPMIN↔GO[
01700		DAC X,XPPMIN↔DAC V,VXMIN↔GO .+1]
01800		LAC Z,ZPP(V)↔CAMGE Z,ZPPMIN↔GO[
01900		DAC Z,ZPPMIN↔DAC V,VZMIN↔GO .+1]
02000		LAC Y,YPP(V)↔CAMGE Y,YPPMIN↔GO[
02100		DAC Y,YPPMIN↔DAC V,VYMIN↔GO .+1]
02200	
02300		LAC X,XPP(V)↔CAMLE X,XPPMAX↔GO[
02400		DAC X,XPPMAX↔DAC V,VXMAX↔GO .+1]
02500		LAC Y,YPP(V)↔CAMLE Y,YPPMAX↔GO[
02600		DAC Y,YPPMAX↔DAC V,VYMAX↔GO .+1]
02700		LAC Z,ZPP(V)↔CAMLE Z,ZPPMAX↔GO[
02800		DAC Z,ZPPMAX↔DAC V,VZMAX↔GO .+1]
02900	
03000		CDR F,7(V)	;PREVIOUS OVER FACE.
03100		JUMPE F,L2
03200		TEST F,POTENT↔GO L2
03300		DAC V,VERT#↔DAC F,FACE#↔PUSH P,B
03400		CALL(WITHIN,FACE,VERT)↔GO L3
03500	L2B:	CALL(ZDEPTH,FACE,VERT)↔JUMPE L3
03600	L2C:	CALL(VHIDE,FACE,VERT)
03700	L3:	POP P,B↔LAC V,VERT↔LAC F,FACE↔GO L2
03800		LIT
03900	BEND;2/27/73------------------------------------------------------
     

00100	SUBR(ESCAN)S0--------------------------------------------------
00200	BEGIN ESCAN; BGB - 10 FEBRUARY 1973.
00300		ACCUMULATORS{E1,E2}
00400		AOS WNDCNT
00500	
00600	;DIAGONOSTIC DISPLAY WINDOW FRAME.
00700		SKIPE DMODE↔GO[CALL(WINDPY,ARG1)
00800		CALL({VERIFY+2},[ASCIZ/ESCAN/],[0])↔GO .+1]
00900	
01000	;COMPARE EACH EDGE IN THE WINDOW WITH ALL THE OTHERS,
01100	;WHEN TWO EDGES CROSS MAKE A TJOINT.
01200	
01300	L0:	LAC E1,ARG1↔DAC E1,EDG1		;FIRST EDGE.
01400		LAC -5(E1)			;EDGE COUNT.
01500		CAIGE 2↔POP1J			;TAKES AT LEAST TWO.
01600		ADD E1↔DAC EOWPTR		;END OF WINDOW.
01700		DZM@
01800		SOS EDG1
01900	
02000	L1:	AOS E1,EDG1↔DAC E1,EDG2
02100		SKIPN E1,(E1)↔POP1J 		;EXIT.
02200		TEST E1,POTENT↔GO L1
02300	
02400	L2:	AOS E2,EDG2
02500		SKIPN E2,(E2)↔GO L1
02600		TEST E2,POTENT↔GO L2
02700	
02800	;COMPARE EDGES.
02900		CALL(COMPEE,@EDG1,@EDG2)
03000		JUMPLE 1,L2
03100		CAIN 1,441↔GO[CALL(MKTJ,@EDG1,@EDG2)↔GO L2]
03200		GO L2
03300	
03400	DECLARE{EDG1,EDG2}
03500	BEND;2/10/73------------------------------------------------------
03600	
03700	;END OF WINDOW POINTER.
03800	EOWPTR:	0
     

00100	SUBR(MKTJ)FOLD,EDGE ---------------------------------------------
00200	BEGIN MKTJ; MAKE T-JOINT.
00300	
00400		LAC ARG2↔DAC FOLD
00500		LAC ARG1↔DAC EDGE
00600		SETQ(JOT,{EBREAK,FOLD})
00700		SETQ(JUT,{EBREAK,EDGE})
00800	
00900	;DISTINGUISH ZPP-OVER ≥ ZPP-UNDER.
01000		LAC 1,JUT↔LAC 2,JOT
01100		TJOIN. 1,2↔TJOIN. 2,1
01200		LAC 0,ZPP(1)↔CAMG 0,ZPP(2)↔GO .+7↔EXCH 1,2
01300		DAC 1,JUT↔DAC 2,JOT
01400		LAC EDGE↔EXCH FOLD↔DAC EDGE
01500		MARK 1,JUTBIT↔MARK 2,JOTBIT
01600	
01700	;ORIENT EDGES WITH RESPECT TO FOLD FACES.
01800		LAC 1,FOLD
01900		PFACE 0,1↔DAC FACE1
02000		NFACE 0,1↔DAC FACE2
02100		SLACI(POTENT)↔AND@FACE1↔AND@FACE2↔ANDCAM@JUT
02200		SETQ(V,{OTHER,EDGE,JUT})
02300		LAC 1,JUT↔PED 1,1↔DAC 1,EJUT
02400		CALL(QFEV,FACE1,FOLD,V)
02500		JUMPG 1,[LAC EDGE↔EXCH EJUT↔DAC EDGE↔GO .+1]
02600	
02700	;HIDE UNDER EDGES.
02800		CALL(,FACE1,EJUT,JUT)
02900		CALL(EHIDE,FACE2,EDGE,JUT)
03000		CALL(EHIDE)
03100		POP2J
03200	COMMENT .                       ⊗	    MAKE T-JOINT MANDALA
03300	                                |
03400	                                |
03500	                    FACE2     FOLD     FACE1
03600	                                |
03700	                    EDGE        ⊗JOT   EJUT
03800	                ⊗-------------⊗-|------------⊗
03900	                V            JUT|
04000	                                |
04100	                                ⊗				.
04200	DECLARE{FOLD,EDGE,EJUT,JOT,JUT,FACE1,FACE2,V}
04300	BEND MKTJ; BGB 14 FEB 73.-----------------------------------------
     

00100	SUBR(EHIDE)FACE,EDGE,VERTEX --------------------------------------
00200	BEGIN EHIDE; EDGE HIDE - BGB - 14 FEBRUARY 1973.
00300	
00400		LAC 1,ARG2↔DAC 1,EDGE↔TEST 1,POTENT↔POP3J
00500		LAC 2,ARG3↔DAC 2,FACE↔TEST 2,POTENT↔POP3J
00600		ALT. 1,2↔PED 0,2↔DAC EDG0↔DAC EDG1
00700		LAC ARG1↔DAC V1↔SETQ(V2,{OTHER,EDGE,V1})
00800		SKIPE DMODE↔GO[CALL(VERIFY,[ASCII/EHIDE/],[3])↔GO .+1]
00900	
01000	;QMASK←(IF V2=NVT(E) THEN 200 ELSE 100).
01100		LACI 200↔LAC 1,EDGE↔NVT 1,1
01200		CAME 1,V2↔LACI 100↔DAC QMASK
01300	
01400	;COMPARE EDGE WITH FACE.
01500	L1:	CALL(COMPEE,EDGE,EDG1)
01600		JUMPLE 1,L2			;DISJOINT.
01700		TDNE 1,QMASK↔GO L3		;V2 TOUCHING EDG1.
01800		TRNN 1,1↔GO L2			;CROSSING.
01900	
02000	;CROSSING - CONTINUE INTO NEXT FACE OR MAKE A TJOINT.
02100	L4:	CALL(OTHER,EDG1,FACE)
02200		TEST 1,POTENT↔GO L5
02300		ALT 0,1↔CAMN 0,EDGE↔POP3J    ;DON'T VISIT SAME FACE TWICE.
02400		LAC 0,EDGE↔ALT. 0,1
02500		DAC 1,FACE↔LAC EDG1↔DAC EDG0
02600	
02700	;DISJOINT - CONTINUE ON THIS FACE OR HIDE EDGE.
02800	L2:	SETQ(EDG1,{ECCW,EDG1,FACE})
02900		CAME 1,EDG0↔GO L1
03000		LAC 1,EDGE↔MARKZ 1,POTENT	        ;HIDE THIS EDGE.
03100		CALL(DPYALL)
03200		CALL(VHIDE,FACE,V2)↔POP3J	  ;HIDE ALL ITS FRIENDS.
03300	
03400	;TOUCHING.
03500	L3:	;OUTSTR[ASCIZ/TOUCH /]
03600		LAC 1,EDGE↔MARKZ 1,POTENT
03700		CALL(DPYALL)↔POP3J
03800	
03900	;MAKE A TJOINT.
04000	L5:	LAC 1,EDGE↔MARKZ 1,POTENT
04100		PVT 1,1↔CAME 1,V2↔GO[CALL(INVERT,EDGE)↔GO .+1]
04200		CALL(EBREAK,EDGE)↔MARK 1,JUTBIT↔PUSH P,1   ;JOINT UNDER T.
04300		CALL(EBREAK,EDG1)↔MARK 1,JOTBIT↔POP P,2	   ;JOINT OVER T.
04400		TJOIN. 1,2↔TJOIN. 2,1
04500		CALL(DPYALL)↔POP3J
04600		LIT
04700	DECLARE{FACE,EDG0,EDG1,EDGE,V1,V2,QMASK}
04800	BEND;2/14/73------------------------------------------------------
     

00100	SUBR(VHIDE)FACE,VERTEX -----------------------------------------
00200	BEGIN VHIDE; HIDE VERTEX V UNDER FACE F.
00300	;VHIDE IS CALLED RECURSIVELY FROM EHIDE SO TEMPORARY CELLS FOR
00400	;V0 AND Z-FACE ARE KEPT IN THE LEFT HALF OF ARG1 AND ARG2.
00500		ACCUMULATORS{V,E,E0}
00600		CDR V,ARG1↔TEST V,POTENT↔POP2J
00700		SKIPE DMODE↔GO[
00800		CALL(VERIFY,[ASCII/VHIDE/],[2])↔CDR V,ARG1↔GO .+1]
00900		DIP V,ARG1	;V0.
01000		MARKZ V,POTENT
01100		CDR 1,ARG2↔DAP 1,7(V)	;FACE HIDES VERTEX.
01200		CALL(ZDEPTH,1,V)↔HLLM 1,ARG2	;Z FACE LEVEL.
01300	
01400	L1:	CDR V,ARG1↔LAC 0,ZPP(V)↔CAML 0,ARG2↔GO L4
01500	L2:	CDR V,ARG1↔PED E,V↔DAC E,E0
01600	L3:	TEST E,POTENT↔GO[
01700		SETQ(E,{ECCW,E,V})↔CAME E,E0↔GO L3↔GO L4]
01800		CDR ARG2↔CALL(EHIDE,0,E,V)↔GO L2
01900	L4:	CDR V,ARG1↔TJOINT V,V↔DAP V,ARG1
02000		SKIPN V↔POP2J
02100		CAR ARG1↔CAME V,0↔GO L1↔POP2J	;TEST FOR V0.
02200	LIT
02300	BEND;2/14/73------------------------------------------------------
     

00100	SUBR(COMPEE)EDG1,EDG2---------------------------------------------
00200	BEGIN COMPEE; COMPARE EDGE-EDGE.
00300		ACCUMULATORS{Q1,Q2,E1,E2,V1,V2,U1,U2}
00400	COMMENT/
00500		-1 EDGES ARE DISJOINT.
00600		 0 EDGES E1 AND E2 ARE IDENTICAL.
00700		+441 EDGE CROSS EACH OTHER.
00800		+110 PVT(E1) IS JOINED TO PVT(E2).
00900		+120 PVT(E1) IS JOINED TO NVT(E2).
01000		+210 NVT(E1) IS JOINED TO PVT(E2).
01100		+220 NVT(E1) IS JOINED TO NVT(E2)./
01200		DEFINE EPSLON<[0.01]>
01300		AOS COMCNT
01400		SETZ 1,↔LAC E1,ARG2↔LAC E2,ARG1
01500		CAMN E1,E2↔POP2J; IDENTITY CASE.
01600	
01700	;FETCH ENDPOINTS - RING'A'AROUND TJOINTS TO GET THE JOT.
01800		PVT V1,E1↔NVT V2,E1
01900		PVT U1,E2↔NVT U2,E2
02000		TESTZ V1,JUTBIT↔GO[TJOINT V1,V1↔GO .-2]
02100		TESTZ V2,JUTBIT↔GO[TJOINT V2,V2↔GO .-2]
02200		TESTZ U1,JUTBIT↔GO[TJOINT U1,U1↔GO .-2]
02300		TESTZ U2,JUTBIT↔GO[TJOINT U2,U2↔GO .-2]
02400	
02500	;TEST FOR EDGES ALREADY HAVINGS A VERTEX OR TJOINT IN COMMON.
02600		NIM 1,110↔CAMN V1,U1↔POP2J
02700		NIM 1,120↔CAMN V1,U2↔POP2J
02800		NIM 1,210↔CAMN V2,U1↔POP2J
02900		NIM 1,220↔CAMN V2,U2↔POP2J
03000	
03100	;THE SPAN OVERLAPPING TESTS PREVENT NASTY PARALLEL CASES.
03200	;TEST FOR X-SPAN NOT OVERLAPPING.
03300		LO1←←0 ↔ HI1←←1 ↔ LO2←←2 ↔ HI2←←3
03400		LAC LO1,XPP(V1)↔LAC HI1,XPP(V2)↔CAMG HI1,LO1↔EXCH HI1,LO1
03500		LAC LO2,XPP(U1)↔LAC HI2,XPP(U2)↔CAMG HI2,LO2↔EXCH HI2,LO2
03600		CAMG LO1,HI2↔GO .+4↔FSBR LO1,HI2↔CAMLE LO1,EPSLON↔GO L0
03700		CAMG LO2,HI1↔GO .+4↔FSBR LO2,HI1↔CAMLE LO2,EPSLON↔GO L0
03800	
03900	;TEST FOR Y-SPAN NOT OVERLAPPING.
04000		LAC LO1,YPP(V1)↔LAC HI1,YPP(V2)↔CAMG HI1,LO1↔EXCH HI1,LO1
04100		LAC LO2,YPP(U1)↔LAC HI2,YPP(U2)↔CAMG HI2,LO2↔EXCH HI2,LO2
04200		CAMG LO1,HI2↔GO .+4↔FSBR LO1,HI2↔CAMLE LO1,EPSLON↔GO L0
04300		CAMG LO2,HI1↔GO .+4↔FSBR LO2,HI1↔CAMLE LO2,EPSLON↔GO[L0:
04400		SETO 1,↔POP2J]
     

00100	;COMPARE E1 AND U1.
00200	L1:	SETZ 1,↔LAC Q1,CC(E1)
00300		LAC BB(E1)↔FMPR YPP(U1)↔FADR Q1,0
00400		LAC AA(E1)↔FMPR XPP(U1)↔FADR Q1,0
00500		LACM Q1↔CAMG EPSLON↔TRO 1,10
00600	
00700	;COMPARE E1 AND U2.
00800		LAC Q2,CC(E1)
00900		LAC BB(E1)↔FMPR YPP(U2)↔FADR Q2,0
01000		LAC AA(E1)↔FMPR XPP(U2)↔FADR Q2,0
01100		LACM Q2↔CAMG EPSLON↔TRO 1,20
01200	
01300	;EXIT WHEN U1 AND U2 ARE CLEAR OF E1 ON THE SAME SIDE.
01400		XOR Q1,Q2↔JUMPGE Q1,[TRNE 1,30↔GO .+2↔SETO 1,↔POP2J]
01500		TRO 1,40   ;E1 CROSSES E2'S LINE.
01600		
01700	;COMPARE E2 AND V1.
01800		LAC Q1,CC(E2)
01900		LAC BB(E2)↔FMPR YPP(V1)↔FADR Q1,0
02000		LAC AA(E2)↔FMPR XPP(V1)↔FADR Q1,0
02100		LACM Q1↔CAMG EPSLON↔TRO 1,100
02200	
02300	;COMPARE E2 AND V2.
02400		LAC Q2,CC(E2)
02500		LAC BB(E2)↔FMPR YPP(V2)↔FADR Q2,0
02600		LAC AA(E2)↔FMPR XPP(V2)↔FADR Q2,0
02700		LACM Q2↔CAMG EPSLON↔TRO 1,200
02800	
02900	;EXIT WHEN V1 AND V2 ARE CLEAR OF E2 ON THE SAME SIDE.
03000		XOR Q1,Q2↔JUMPGE Q1,[TRNE 1,300↔GO .+2↔SETO 1,↔POP2J]
03100		TRO 1,400	 ;E2 CROSSES E1'S LINE.
03200	
03300	;ELIMINATE COINCIDANT EDGE-VERTEX OCCURENCES BY FUDGING.
03400		TRNE 1,010↔GO[CALL(FUDGE,U1,E1)↔GO L1] ;U1 NEAR E1'S LINE.
03500		TRNE 1,020↔GO[CALL(FUDGE,U2,E1)↔GO L1] ;U2 NEAR E1'S LINE.
03600		TRNE 1,100↔GO[CALL(FUDGE,V1,E2)↔GO L1] ;V1 NEAR E2'S LINE.
03700		TRNE 1,200↔GO[CALL(FUDGE,V2,E2)↔GO L1] ;V2 NEAR E2'S LINE.
03800	
03900	;SOLVE FOR CROSSING LOCUS.
04000	L2:	DAC 1,AC1
04100		LAC AA(E1)↔FMPR BB(E2)
04200		LAC 1,AA(E2)↔FMPR 1,BB(E1)↔FSBR 0,1↔DAC TT#
04300		LAC BB(E1)↔FMPR CC(E2)
04400		LAC 1,BB(E2)↔FMPR 1,CC(E1)↔FSBR 0,1↔FDVR 0,TT↔DAC XCROSS
04500		LAC CC(E1)↔FMPR AA(E2)
04600		LAC 1,CC(E2)↔FMPR 1,AA(E1)↔FSBR 0,1↔FDVR 0,TT↔DAC YCROSS
04700		LAC XCROSS↔FMPR[3.5]↔DAC XCRUX
04800		LAC YCROSS↔FMPR[3.5]↔DAC YCRUX
04900		LAC 1,AC1↔TRO 1,1↔POP2J
05000	BEND;3/1/73-------------------------------------------------------
05100		DECLARE{XCROSS,YCROSS,ZCROSS,XCRUX,YCRUX}
     

00100	SUBR(FUDGE)VERTEX,EDGE -------------------------------------------
00200	BEGIN FUDGE; MOVE 2D VERTEX LOCUS AWAY FROM THE EDGE ALITTLE.
00300		EXTERN ECOEF
00400		ACCUMULATORS{V,E}↔SAVAC(11)
00450		SKIPE DMODE↔GO[CALL(VERIFY,[ASCII/FUDGE/],[2])↔GO .+1]
00500		LAC V,ARG2↔LAC E,ARG1↔DAC V,VERT
00600		LAC BB(E)↔FSC -3↔FADRM YPP(V)
00700		LAC AA(E)↔FSC -3↔FADRM XPP(V)
00800		PED E,V↔DAC E,E0↔DAC E,E1
00900	L:	CALL(ECOEF,E1)
01000		SETQ(E1,{ECCW,E1,VERT})
01100		CAME 1,E0↔GO L
01200		GETAC(11)↔POP2J
01300		DECLARE{E0,E1,VERT}
01400	BEND FUDGE;BGB 3/1/73---------------------------------------------
01500	
01600	
01700	SUBR(ZDEDGE)EDGE -------------------------------------------------
01800	BEGIN ZDEDGE; SOLVE FOR ZDEPTHS AT THE CROSSING(XCROSS,YCROSS).
01900	;Z←((Z2-Z1)*(XCROSS-X1)/(X2-X1))+Z1
02000		ACCUMULATORS{E,V1,V2}
02100		
02200		LAC E,ARG1
02300		PVT V1,E↔NVT V2,E
02400		LACM 0,AA(E)↔LACM 1,BB(E)↔CAMGE 1,0↔GO L
02500	
02600	;WHEN DX ≥ DY:
02700		LAC 1,ZPP(V2)↔FSBR 1,ZPP(V1)
02800		LAC 0,XCROSS↔ FSBR 0,XPP(V1)↔FMPR 1,0
02900		LAC 0,XPP(V2)↔FSBR 0,XPP(V1)↔FDVR 1,0
03000		FADR 1,ZPP(V1)↔DAC 1,ZCROSS↔POP1J
03100	
03200	;WHEN DY > DX:
03300	L:	LAC 1,ZPP(V2)↔FSBR 1,ZPP(V1)
03400		LAC 0,YCROSS↔ FSBR 0,YPP(V1)↔FMPR 1,0
03500		LAC 0,YPP(V2)↔FSBR 0,YPP(V1)↔FDVR 1,0
03600		FADR 1,ZPP(V1)↔DAC 1,ZCROSS↔POP1J
03700	BEND;2/10/73------------------------------------------------------
     

00100	SUBR(EBREAK)EDGE -------------------------------------------------
00200	BEGIN EBREAK;EBREAK(EDGE) IS LIKE ESPLIT.
00300		ACCUMULATORS{B,E,V,Q,R,ENEW,VNEW,PV,NV}
00400	
00500	;GET ZDEPTH AT CROSSING.
00600		CALL(ZDEDGE,ARG1)
00700	;CREATE A NEW EDGE AND A NEW VERTEX.
00800		CDR E,ARG1↔PVT V,E↔CCW B,E
00900		SETQ(VNEW,{MKV,B})↔MARK VNEW,TMPBIT+POTENT
01000		EXCH 1,TJLIST↔TJ. 1,VNEW	;CONS VNEW TO TJ LIST.
01100		LAC XCROSS↔DAC XPP(VNEW)↔LAC XCRUX↔XDC. 0,VNEW
01200		LAC YCROSS↔DAC YPP(VNEW)↔LAC YCRUX↔YDC. 0,VNEW
01300		LAC ZCROSS↔DAC ZPP(VNEW)
01400		SETQ(ENEW,{MKE,B})↔MARK ENEW,POTENT
01500		TESTZ E,FOLDED↔GO[MARK ENEW,FOLDED↔GO .+1]
01510		TESTZ E,DARKEN↔GO[MARK ENEW,DARKEN↔GO .+1]
01600	
01700	;COPY EDGE COEFFICIENTS.
01800		SLACI AA(E)↔LAPI AA(ENEW)↔BLT CC(ENEW)
01850		LAC 8(E)↔DAC 8(ENEW)
01900	;PLACE EDGE AT END OF POTENT EDGE LIST.
02000		LAC 1,WORLD↔NED 2,1↔NED. ENEW,1↔POTEN. ENEW,2
02100		SKIPN EOWPTR↔GO .+4
02200		DAC ENEW,@EOWPTR↔AOS EOWPTR↔DZM@EOWPTR
02300	;PLACE VNEW BETWEEN E AND ENEW.
02400		PED 0,V↔CAMN 0,E↔PED. ENEW,V
02500		PED. ENEW,VNEW↔PVT PV,E↔PVT. PV,ENEW
02600		PVT. VNEW,E↔NVT. VNEW,ENEW
02700		PFACE 0,E↔PFACE. 0,ENEW
02800		NFACE 0,E↔NFACE. 0,ENEW
02900	;NEW UPPER WINGS ARE LIKE THE OLDE;
03000		PCW 0,E↔CALL(WING,0,ENEW)
03100		NCCW 0,E↔CALL(WING,0,ENEW)
03200	;EDGES POINT AT EACH OTHER ACROSS VNEW.
03300		NCCW. ENEW,E↔PCW.  ENEW,E
03400		NCW.  E,ENEW↔PCCW. E,ENEW
03500		LAC 1,VNEW↔POP1J
03600	COMMENT . _________     __________	EBREAK MANDALA
03700	            nccw   \   /   pcw
03800	                    \ /
03900	                   + ⊗ V
04000	                    +|
04100	                     | ENEW
04200	                    -|     
04300	                     ⊗ VNEW
04400	                    +|
04500	                     |  E
04600	                    -|
04700	                   - ⊗
04800	                    / \
04900	          ___ncw___/   \___pccw___.
05000	BEND;2/10/73------------------------------------------------------
     

00100	SUBR(TJSCAN)------------------------------------------------------
00200	BEGIN TJSCAN; SCAN TJ LIST & PROMULAGATE UNDER FACES.
00300		ACCUMULATORS{UF1,UF2,JUT,JOT,F1,F2,E,E1,E2,V1}
00400	;SCAN THRU TJ-LIST FOR POTENT JUTS.
00500		SKIPA JUT,TJLIST;                       ⊗V1
00600	L1:	TJ JUT,JUT;                             |
00700		SKIPN JUT↔POP0J;            F1      UF1 |E1
00800		TEST JUT,JUTBIT↔GO L1;                  |
00900		TEST JUT,POTENT↔GO L1;      EDGE   JUT  ⊗JOT
01000		PUSH P,JUT;             ⊗-------------⊗-|------------⊗
01100	;		                                |
01200	;		                    F2      UF2 |E2
01300	;		                                |
01400	;		                                ⊗
01500	
01600	;PICKUP ALL THE FRIENDS OF THE PRESENT JUT.
01700		TJOINT JOT,JUT↔PED E1,JOT		;JOT'S EDGES.
01800		SETQ(E2,{ECCW,E1,JOT})
01900		SETQ(V1,{OTHER,E1,JOT})
02000		PED E,JUT↔TEST E,POTENT↔GO[		;POTENT JUT EDGE.
02100		SETQ(E,{ECCW,E,JUT})↔GO .+1]
02200		PFACE F1,E↔TEST F1,POTENT↔DZM F1	;POTENT JUT FACES.
02300		NFACE F2,E↔TEST F2,POTENT↔DZM F2
02400	
02500	;FORCE ORIENTATION AS IN THE MANDALA.
02600		LAC 1,CC(E)
02700		LAC BB(E)↔FMPR YPP(V1)↔FADR 1,0
02800		LAC AA(E)↔FMPR XPP(V1)↔FADR 1,0
02900		SKIPG 1↔EXCH E1,E2
03000	
03100	;TRY TO HIDE THE JUT.
03200		UFACE UF1,E1↔SKIPE UF1
03300		CAMN UF1,F1↔GO L2
03400		CALL(ZDEPTH,UF1,JUT)↔JUMPE L2
03500		CALL(VHIDE,UF1,JUT)↔GO L9
03600	L2:	UFACE UF2,E2↔SKIPE UF2
03700		CAMN UF2,F2↔GO L3
03800		CALL(ZDEPTH,UF2,JUT)↔JUMPE L3
03900		CALL(VHIDE,UF2,JUT)↔GO L9
04000	
04100	;PROMULGATE UNDERFACES OF THIS JOT.
04200	L3:	CALL(,F2,E2,JOT)
04300		CALL(PROMUL,F1,E1,JOT)
04400		CALL(PROMUL)
04500	L9:	POP P,JUT↔GO L1
04600	
04700	BEND TJSCAN;BGB 4 MARCH 1973 -------------------------------------
     

00100	SUBR(PROMUL)UF,EDGE,VERTEX----------------------------------------
00200	BEGIN PROMUL;PROMULGATE UNDER FACE ALONG THE FOLDS.
00300		ACCUMULATORS{A2,A3,E,V,F,JUT}
00400		SKIPN F,ARG3↔POP3J
00500		LAC E,ARG2↔TEST E,POTENT↔POP3J
00600		LAC V,ARG1↔TEST V,POTENT↔POP3J
00700		SKIPE DMODE↔GO[CALL(VERIFY,[ASCII/PROML/],[3])
00800		LAC F,ARG3↔LAC E,ARG2↔LAC V,ARG1↔GO .+1]
00900	
01000	;PLACE UF IN EDGE IF DIFFERENT FROM THE ONE IT MAY HAVE ALREADY.
01100		UFACE 1,E↔CAMN 1,F↔POP3J	;CONSISTENT.
01200		UFACE. F,E
01300	L1:	SETQ(V,{OTHER,E,V})
01400		TESTZ V,JUTBIT↔POP3J
01500		TESTZ V,JOTBIT↔GO L3
01600		VALEN 0,V↔CAILE 0,3↔POP3J	;EXIT ON COMPLEX VERTICES.
01700	
01800	;PROMULGATE UNDER FACE THRU A SIMPLE TWO FOLD VERTEX.
01900		DAC E,1
02000	L2:	CALL(ECCW,1,V)
02100		CAMN 1,E↔POP3J
02200		TEST 1,FOLDED↔GO L2	
02300		GO L1
02400	
02500	;SEE IF WE CAN WIPE THIS JOT'S JUT.
02600	L3:	TEST V,VBIT↔GO[FATAL({BUG TRAP PROMUL&L3})]
02700		TJOINT JUT,V
02800		TEST JUT,POTENT↔GO L2-1
02900		PED 1,JUT
03000		PFACE 0,1↔CAMN 0,F↔POP3J
03100		NFACE 0,1↔CAMN 0,F↔POP3J
03200		DAC F,ARG3↔DAC E,ARG2↔DAC V,ARG1
03300		CALL(ZDEPTH,F,JUT)↔JUMPE POP3J.
03400		CALL(WITHIN,F,JUT)↔POP3J
03500		CALL(VHIDE,F,JUT)
03600		GO PROMUL
03700	
03800	BEND PROMUL;BGB 4 MARCH 1972 -------------------------------------
     

00100	SUBR(QEV)E,V------------------------------------------------------
00200	BEGIN QEV
00300		ACCUMULATORS{E,V}
00400		LAC V,ARG1
00500		LAC E,ARG2
00600		LAC 1,CC(E)
00700		LAC BB(E)↔FMPR YPP(V)↔FADR 1,0
00800		LAC AA(E)↔FMPR XPP(V)↔FADR 1,0
00900		POP2J
01000	BEND;2/10/73------------------------------------------------------
01100	
01200	SUBR(QFEV)F,E,V --------------------------------------------------
01300	BEGIN QFEV
01400		ACCUMULATORS{E,V}
01500		LAC V,ARG1
01600		LAC E,ARG2
01700		LAC 1,CC(E)
01800		LAC BB(E)↔FMPR YPP(V)↔FADR 1,0
01900		LAC AA(E)↔FMPR XPP(V)↔FADR 1,0
02000		PFACE 0,E↔CAME 0,ARG3↔MOVNS 1
02100		POP3J
02200	BEND;2/10/73------------------------------------------------------
02300	
02400	SUBR(CROSSING)X,Y,E1,E2 ------------------------------------------
02500	BEGIN CROSSING
02600		ACCUMULATORS{TT,XPTR,YPTR,E1,E2}
02700		LAC E2,ARG1
02800		LAC E1,ARG2
02900		LAC YPTR,ARG3
03000		LAC XPTR,ARG4
03100		LAC AA(E1)↔FMPR BB(E2)
03200		LAC 1,AA(E2)↔FMPR 1,BB(E1)↔FSBR 0,1↔DAC TT
03300		LAC BB(E1)↔FMPR CC(E2)
03400		LAC 1,BB(E2)↔FMPR 1,CC(E1)↔FSBR 0,1↔FDVR 0,TT↔DAC(XPTR)
03500		LAC CC(E1)↔FMPR AA(E2)
03600		LAC 1,CC(E2)↔FMPR 1,AA(E1)↔FSBR 0,1↔FDVR 0,TT↔DAC(YPTR)
03700		POP4J
03800	BEND;2/10/73------------------------------------------------------
     

00100	SUBR(ZDEPTH)FACE,VERTEX ------------------------------------------
00200	BEGIN ZDEPTH; RETURN AC0 -1 VERTEX UNDER FACE.
00300		ACCUMULATORS{F,V}
00400		LAC V,ARG1
00500		LAC F,ARG2
00600		LAC 1,KK(F)
00700		LAC AA(F)↔FMPR XPP(V)↔FSBR 1,0
00800		LAC BB(F)↔FMPR YPP(V)↔FSBR 1,0
00900		FDVR 1,CC(F)
01000		SETO↔CAMG 1,ZPP(V)↔SETZ		;ZPP-OVER > ZPP-UNDER.
01100		POP2J
01200	BEND;2/10/73------------------------------------------------------
01300	
01400	SUBR(ZDALT)FACE,XPP,YPP ------------------------------------------
01500	BEGIN ZDALT
01600		ACCUMULATORS{F}
01700		LAC F,ARG3
01800		LAC 1,KK(F)
01900		LAC AA(F)↔FMPR ARG2↔FSBR 1,0
02000		LAC BB(F)↔FMPR ARG1↔FSBR 1,0
02100		FDVR 1,CC(F)
02200		POP3J
02300	BEND;2/10/73------------------------------------------------------
02400	
02500	SUBR(WITHIN)FACE,VERTEX ------------------------------------------
02600	BEGIN WITHIN
02700		ACCUMULATORS{F,V,E,E0}
02800		LAC F,ARG2
02900		LAC V,ARG1
03000		PED E,F↔DAC E,E0
03100	L1:	LAC 1,CC(E)
03200		LAC BB(E)↔FMPR YPP(V)↔FADR 1,0
03300		LAC AA(E)↔FMPR XPP(V)↔FADR 1,0
03400		PFACE 0,E↔CAME 0,F↔MOVNS 1
03500	L2:	JUMPLE 1,POP2J.			;VERTEX OUTSIDE FACE.
03600		SETQ(E,{ECCW,E,F})
03700		CAME E,E0↔GO L1
03800		AOS(P)↔POP2J			;SKIP VERTEX WITHIN FACE.
03900	BEND;2/27/73------------------------------------------------------
     

00100	SUBR(KLJOTS)WORLD-------------------------------------------------
00200	BEGIN KLJOTS
00300		ACCUMULATORS{B,V}
00400		CDR B,ARG1
00500	L1:	CCW B,B↔CAMN B,ARG1↔POP1J
00600	;FOR ALL THE VERTICES OF EACH BODY.
00700		LAC V,B
00800	L2:	NVT V,V↔CAMN V,B↔GO L1
00900		TEST V,TMPBIT↔GO L2
01000		TEST V,JOTBIT↔GO L2
01100		NVT V,V↔PUSH P,V↔PUSH P,B
01200		PVT V,V↔CALL(KLEV,V)
01300		POP P,B↔POP P,V↔GO L2+1
01400	BEND KLJOTS; BGB 16 FEB 1973 -------------------------------------
01500	
01600	SUBR(KLJUTS)WORLD-------------------------------------------------
01700	BEGIN KLJUTS
01800		ACCUMULATORS{B,V}
01900		LAC B,ARG1
02000	L1:	CCW B,B↔CAMN B,ARG1↔POP1J
02200	;FOR ALL THE VERTICES OF EACH BODY.
02300		LAC V,B
02400	L2:	NVT V,V
02500		TEST V,VBIT↔GO L1
02600		TEST V,TMPBIT↔GO L2
02700		TEST V,JUTBIT↔GO L2
02800		NVT V,V↔PUSH P,V↔PUSH P,B
02900		PVT V,V↔CALL(KLEV,V)
03000		POP P,B↔POP P,V↔GO L2+1
03100	BEND KLJUTS; 16 FEB 1973 -----------------------------------------
03200	
     

00100	SUBR(KLTMPS)WORLD-------------------------------------------------
00200	BEGIN KLTMPS; KILL ALL THE TMP VERTICES IN THE WORLD.
00300		ACCUMULATORS{B,V,E}
00400		LAC B,ARG1
00500	L1:	CCW B,B↔CAMN B,ARG1↔POP1J
00550	
00600		LAC E,B
00700	L2:	NED E,E↔CAMN E,B↔GO L3-1
00800		TEST E,TMPBIT↔GO L2
00900		NED E,E↔PUSH P,E↔PUSH P,B
01000		PED E,E↔CALL(KLFE,E)
01100		POP P,B↔POP P,E↔GO L2+1
01200	
01300		LAC V,B
01400	L3:	NVT V,V↔CAMN V,B↔GO L1
01500		TEST V,TMPBIT↔GO L3
01600		NVT V,V↔PUSH P,V↔PUSH P,B
01700		PVT V,V↔CALL(KLEV,V)
01800		POP P,B↔POP P,V↔GO L3+1
01900	BEND KLTMPS; BGB 16 MARCH 1973 -----------------------------------
     

00100	SUBR(VERIFY)NAME,ARGCNT ------------------------------------------
00200	BEGIN VERIFY; DIAGONOSTIC DISPLAY FOR VERIFYING CORRECTNESS.
00300		EXTERN IDPY
00400		CALL(DPYSET,DPYBUF)
00500		AOS STEP
00600		CALL(AIVECT,[-=510],[-=220])
00700		CALL(DECDPY,STEP)↔CALL(DPYSTR,{[[ASCIZ/. /]]})
00800		LAC ARG2↔DAC NAME↔CALL(DPYSTR,[NAME])
00900	
01000	;GET POINTER TO HIS ARGUMENTS.
01100		LACI 16,-3(17)		;STACK POINTER TO HIS RETURN ADR.
01200		LAC  ARG1↔SUB 16,0
01300		MOVNS↔DIP 0,16		;AOBJN POINTER.
01400		DAC 16,SAV#
01500		JUMPE 0,L3		;HE'S GOT NO ARGUMENTS.
01600	
01700	;DISPLAY ARGUMENT LIST.
01800		PUSH P,["("]↔SKIPA
01900	L0:	CALL(DTYO,{[","]})↔CDR 1,(16)↔CALL(IDPY,1)↔AOBJN 16,L0
02000		CALL(DTYO,{[")"]})
02100	
02200		LAC 16,SAV
02300	L1:	CDR 1,(16)↔JUMPE 1,L2			;GET AN ARGUMENT.
02400		LAC 0,(1)			       ;GET ITS TYPE BITS.
02500		TLNE(FBIT)↔GO[CALL(FDPY,1)↔GO L2]
02600		TLNE(EBIT)↔GO[CALL(EDPY,1)↔GO L2]
02700		TLNE(VBIT)↔GO[CALL(VDPY,1)↔GO L2]
02800	L2:	AOBJN 16,L1
02900	
03000	L3:	CALL(DPYOUT,[16])
03100		SETZ↔SKIPE RUNFLG↔GO L4
03200		
03300	;NOT RUNNING - SINGLE STEP VERIFICATION.
03400		INCHRW
03500		CAIN 175↔SETOM RUNFLG
03600		CAIL"0"↔CAILE"9"↔POP2J
03700		ANDI 17↔LAC 1,STEP2
03800		IMULI 1,=10↔ADD 1↔DAC STEP2
03900		GO L3
04000	
04100	;RUNNING UNTIL STEP2 OR CHR.
04200	L4:	SKIPE 1,STEP2↔CAMLE 1,STEP↔GO .+4
04300		DZM STEP2↔DZM RUNFLG↔GO L3
04400		INCHRS↔POP2J↔DZM RUNFLG↔GO L3
04500		RUNFLG:0
04600		NAME:0↔0
04700		STEP:0
04800		STEP2:0
04900	BEND;2/24/73------------------------------------------------------
     

00100	FDPY:;------------------------------------------------------------
00200	BEGIN FDPY
00300		LAC 1,ARG1↔DAC 1,F
00400		PED 1,1↔DAC 1,E0↔DAC 1,E
00500		CALL(DPYBRT,[3])
00600		CALL(VCW,E,F)
00700		XDC 0,1↔FIXX↔YDC 1,1↔FIXX 1,↔CALL(AIVECT,0,1)
00800	L:	CALL(VCCW,E,F)
00900		XDC 0,1↔FIXX↔YDC 1,1↔FIXX 1,↔CALL(AVECT,0,1)
01000		SETQ(E,{ECCW,E,F})
01100		CAME 1,E0↔GO L↔CALL(DPYBRT,[2])↔POP1J
01200		DECLARE{F,E,E0}
01300	BEND;2/10/73------------------------------------------------------
01400	
01500	DPYALL:;----------------------------------------------------------
01600	BEGIN DPYALL
01700		EXTERN AIVECT,AVECT
01800		SKIPN DMODE↔POP0J
01900		CALL(DPYSET,DPYBUF)
02000		LAC 1,WORLD↔DAC 1,B
02100	L1:	LAC 1,B#↔CCW 1,1↔DAC 1,B
02200		TEST 1,BBIT↔GO[CALL(DPYOUT,[1])↔POP0J]
02300		DAC 1,E#↔DZM CNT#
02400	L2:	LAC 1,E↔PED 1,1↔DAC 1,E↔AOS CNT
02500		TEST 1,EBIT↔GO L1
02600		TEST 1,POTENT↔GO L2
02700		PVT 2,1↔NVT 3,1
02800		XDC 0,3↔FIXX↔PUSH P,
02900		YDC 0,3↔FIXX↔PUSH P,
03000		XDC 0,2↔FIXX↔PUSH P,
03100		YDC 0,2↔FIXX↔PUSH P,
03200		CALL(AIVECT)
03300		CALL(AVECT)
03400		GO L2
03500	BEND;2/10/73------------------------------------------------------
     

00100	SUBR(WINDPY)S0 ---------------------------------------------------
00200	BEGIN WINDPY; WINDOW DISPLAY.
00300		E←←S0←←12↔XL←←13↔XH←←14↔YL←←15↔YH←←16
00400		CALL(DPYSET,DPYBUF)↔LAC 1,ARG1
00500		SLACI -4(1)↔LAPI XL↔BLT YH
00600		FMP XL,[3.5]↔FIXX XL,↔FMP YL,[3.5]↔FIXX YL,
00700		FMP XH,[3.5]↔FIXX XH,↔FMP YH,[3.5]↔FIXX YH,
00800		CALL(AIVECT,XL,YL)
00900		CALL(AVECT,XH,YL)↔CALL(AVECT,XH,YH)
01000		CALL(AVECT,XL,YH)↔CALL(AVECT,XL,YL)
01100		CALL(DPYOUT,[14])↔CALL(DPYBRT,[5])
01200		LAC S0,ARG1↔LACN -5(S0)↔DIP S0
01300		SKIPE↔GO[LAC 1,(S0)↔PVT 2,1↔NVT 1,1
01400			XDC XL,1↔YDC YL,1↔XDC XH,2↔YDC YH,2
01500			FIXX XL,↔FIXX YL,↔FIXX XH,↔FIXX YH,
01600			CALL(AIVECT,XL,YL)↔CALL(AVECT,XH,YH)
01700			AOBJN S0,.↔GO .+1]
01800		LAC 1,ARG1↔LAC E,-6(1)
01900	L1:	POTEN E,E↔JUMPE E,POP1J.
02000		TEST E,POTENT↔GO L1
02100		CALL(EDPY,E)↔GO L1
02200		POP1J
02300	BEND WINDPY;
     

00100	SUBR(STAT)--------------------------------------------------------
00200	BEGIN STAT; DISPLAY OCCULT STATISTICS.
00300		CALL(DPYSET,BUFDPY)
00400	 	SETZ↔TIMER↔SUB TIME1↔MOVM↔FLOAT↔FDVR[60.0]↔DAC TIME1
00500		SETZ↔RUNTIM↔SUB TIME2↔MOVM↔FLOAT↔FDVR[1000.0]↔DAC TIME2
00600		FDVR TIME1↔FMPR[100.0]↔FIXX↔DAC RATIO#
00700	
00800		CALL(DPYBIG,[1])
00900		CALL(AIVECT,[=380],[=430])
01000		CALL(DPYSTR,{[[ASCIZ/REAL TIME /]]})
01100		CALL(FLODPY,TIME1,[2])
01200		CALL(AIVECT,[=380],[=410])
01300		CALL(DPYSTR,{[[ASCIZ/RUN  TIME /]]})
01400		CALL(FLODPY,TIME2,[2])
01500		CALL(AIVECT,[=380],[=390])
01600		CALL(DPYSTR,{[[ASCIZ/TIME SHARE /]]})
01700		CALL(DECDPY,RATIO)
01800		CALL(DTYO,["%"])
01900	
02000		CALL(AIVECT,[=150],[-=400])
02100		CALL(DPYSTR,{[[ASCIZ/PDLTOP /]]})↔CALL(DECDPY,PDLTOP)
02200		CALL(DPYSTR,{[[ASCIZ/   WINDOWS /]]})↔CALL(DECDPY,WNDCNT)
02300		CALL(DPYSTR,{[[ASCIZ/   COMPARES /]]})↔CALL(DECDPY,COMCNT)
02400		CALL(DPYBIG,[2])
02500		CALL(DPYOUT,[16])
02600		
02700		SKIPN DMODE↔POP0J
02800		CALL(DPYSET,DPYBUF)
02900		CALL(DPYOUT,[15])
03000		CALL(DPYOUT,[14])
03100		POP0J
03200		LIT
03300	BEND STAT;BGB 3/4/73----------------------------------------------
03400	
03500	END